home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 2: CDPD 1 / Almathera Ten on Ten - Disc 2: CDPD 1.iso / pd / 076-100 / 084 / gravitywars / mywindow.mod < prev    next >
Text File  |  1995-03-13  |  14KB  |  401 lines
  1. IMPLEMENTATION MODULE MyWindow;
  2. (*+,+*)
  3.  
  4. (**********************************************************************
  5. ***************           Written by Ed Bartz           ***************
  6. ***************           Copyright  5/21/87            ***************
  7. ***************    This program may be redistributed    ***************
  8. ***************    or modified as long as these         ***************
  9. ***************    notices and all other references     ***************
  10. ***************    to the author remain intack.         ***************
  11. ***************    Also this may not be used for        ***************
  12. ***************    profit by anyone without the         ***************
  13. ***************    express permission of the author.    ***************
  14. **********************************************************************)
  15.  
  16. FROM Ports IMPORT ReplyMsg, WaitPort, GetMsg, MessagePtr;
  17. FROM Colors IMPORT SetRGB4;
  18. FROM Libraries IMPORT OpenLibrary, CloseLibrary;
  19. FROM SYSTEM     IMPORT ADR, BYTE, ADDRESS, NULL;
  20. FROM Intuition  IMPORT
  21.      IntuitionName, IntuitionBase, Window, WindowFlags, NewWindow,
  22.      MenuPick, IDCMPFlagSet, WindowFlagSet, WindowPtr, ScreenPtr,
  23.      MenuEnabled, MenuFlagSet, Menu, MenuItem, IntuitionText, ActiveWindow,
  24.      ItemFlagSet, ItemText, ItemEnabled, IntuiMessagePtr, CustomScreen,
  25.      MouseButtons, SelectDown, CheckIt, MenuToggle, InactiveWindow;
  26. FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase, Jam2, Jam1,
  27.      DrawingModeSet;
  28. FROM Windows IMPORT OpenWindow, CloseWindow, ModifyIDCMP;
  29. FROM Screens IMPORT 
  30.      NewScreenPtr, NewScreen, OpenScreen, CloseScreen, ShowTitle;
  31. FROM Views IMPORT Lace, Hires, ModeSet;
  32. FROM Menus IMPORT HighComp, SetMenuStrip;
  33. FROM Text IMPORT TextAttr,Text,NormalStyle,FontFlags,FontFlagSet;
  34. FROM Console   IMPORT OpenWConsole,CloseWConsole,Conport;
  35.  
  36.  
  37.    PROCEDURE OpenLibraries () : BOOLEAN;
  38.      BEGIN
  39.      (* First open intuition library *)
  40.      IntuitionBase := OpenLibrary (IntuitionName, 0);
  41.      IF IntuitionBase = 0 THEN RETURN FALSE END;
  42.      (* Now open the graphics library *)
  43.      GraphicsBase := OpenLibrary (GraphicsName, 0);
  44.      IF GraphicsBase = 0 THEN RETURN FALSE END;
  45.      RETURN TRUE
  46.    END OpenLibraries;
  47. (*++++++++++++++++++++++++++++++++++++++ *)
  48.    PROCEDURE InitScreen () : ScreenPtr;
  49.  
  50.      VAR
  51.        s : NewScreenPtr;
  52.        GravityWarsName : ARRAY [0..15] OF CHAR;
  53.        FontType : ARRAY [0..15] OF CHAR;
  54.        textattr : TextAttr;
  55.  
  56.      BEGIN
  57.      FontType := "topaz.font";
  58.      GravityWarsName := "GravityWars";
  59.      WITH s^ DO
  60.        LeftEdge := 0; TopEdge := 0;
  61.        Width := 640; Height := 400;
  62.        Depth := 4;
  63.        DetailPen := BYTE (0); BlockPen := BYTE (1);
  64.        ViewModes := ModeSet {Lace, Hires};
  65.        Type := CustomScreen;
  66.        Font := ADR(textattr);
  67.        DefaultTitle := ADR (GravityWarsName);
  68.        Gadgets := NULL;
  69.        CustomBitMap := NULL
  70.      END;
  71.      WITH textattr DO
  72.        taName :=ADR(FontType);
  73.        taYSize := 9;
  74.        taStyle := NormalStyle;
  75.        taFlags := FontFlagSet{ROMFont};
  76.      END;
  77.      (* Now open the screen *)
  78.      RETURN OpenScreen (s)
  79.    END InitScreen;
  80. (*++++++++++++++++++++++++++++++++++++++ *)
  81. (* Initialize and open a window.         *)
  82.   PROCEDURE InitWindow (screen : ScreenPtr) : WindowPtr;
  83.     VAR
  84.       w : NewWindow;
  85.  
  86.     BEGIN
  87.       WITH w DO
  88.         LeftEdge := 0; TopEdge := 0; Width := 640; Height := 400;
  89.         DetailPen := BYTE (0);
  90.         BlockPen := BYTE (1);
  91.         Title := NULL;
  92.         Flags := WindowFlagSet {Activate, Borderless};
  93.         IDCMPFlags := IDCMPFlagSet {MenuPick,MouseButtons};
  94.         Type := CustomScreen;
  95.         CheckMark := NULL;
  96.         FirstGadget := NULL;;
  97.         Screen := screen;
  98.         BitMap := NULL;
  99.         MinWidth := 10; MinHeight := 10;
  100.         MaxWidth := 640; MaxHeight := 400;
  101.       END;
  102.      (* Now open the window *)
  103.       RETURN OpenWindow (w)
  104.   END InitWindow;
  105. (*++++++++++++++++++++++++++++++++++++++ *)
  106. (* Initialize and open an IO window.  *)
  107. PROCEDURE OpenIOWin(VAR W: Conport;VAR w :WindowPtr; scn: ScreenPtr): BOOLEAN;
  108.  
  109.     VAR
  110.       Win     : NewWindow;
  111.       error   : LONGINT;
  112.  
  113.     BEGIN
  114.       WITH Win DO
  115.         LeftEdge := 0; TopEdge := 0; Width := 640; Height := 30;
  116.         DetailPen := BYTE (2);
  117.         BlockPen := BYTE (1);
  118.         Title := NULL;
  119.         Flags := WindowFlagSet {Borderless};
  120.         IDCMPFlags := IDCMPFlagSet {InactiveWindow};
  121.         Type := CustomScreen;
  122.         CheckMark := NULL;
  123.         FirstGadget := NULL;;
  124.         Screen := scn;
  125.         BitMap := NULL;
  126.         MinWidth := 639; MinHeight := 10;
  127.         MaxWidth := 640; MaxHeight := 50;
  128.       END;
  129.      (* Now open the window *)
  130.        w:=OpenWindow(Win);
  131.      RETURN OpenWConsole(W,w);
  132.   END OpenIOWin;
  133. (*++++++++++++++++++++++++++++++++++++++ *)
  134.   PROCEDURE CloseIOWin (VAR W: Conport;w :WindowPtr );
  135.  
  136.     BEGIN
  137.         CloseWConsole(W);
  138.         CloseWindow(w);
  139.     END CloseIOWin;
  140. (*++++++++++++++++++++++++++++++++++++++ *)
  141. PROCEDURE InitMenu (VAR GravityWarsmenu: MenuData);
  142.  
  143.      PROCEDURE InitItems ();
  144.  
  145.        VAR
  146.          i : CARDINAL;
  147.        BEGIN
  148.          WITH GravityWarsmenu DO
  149.            FOR i := 0 TO 34 DO
  150.              (* Initialize Item record fields *)
  151.              WITH Items[i] DO
  152.                NextItem := ADR (Items[i+1]);
  153.                IF ((i=8) OR (i=12) OR (i=17) OR (i=22) OR (i=34)) THEN
  154.                  NextItem := NULL
  155.                END;
  156.                LeftEdge := 0;
  157.                Width := 190; Height := 10;
  158.                Flags := ItemFlagSet {ItemText, ItemEnabled} + HighComp;
  159.                MutualExclude := 0;
  160.                ItemFill := ADR (Itemtext[i]);
  161.                SelectFill := NULL; Command := BYTE (0);
  162.                SubItem := NULL;  NextSelect := 0;
  163.              END;
  164.              WITH Itemtext [i] DO
  165.                FrontPen := BYTE(0); BackPen := BYTE (1);
  166.                DrawMode := BYTE (DrawingModeSet {Jam2});
  167.                LeftEdge := 0; TopEdge := 1;
  168.                ITextFont := NULL; NextText := NULL;
  169.                IText := ADR (Text[i])
  170.             END;
  171.           END;
  172.           FOR i:= 0 TO 8 DO
  173.             Items[i].TopEdge := i* 10;
  174.             Items[i].Width := 250;
  175.           END;
  176.           FOR i:= 9 TO 12 DO          
  177.             Items[i].TopEdge := (i-9) * 10;
  178.             Items[i].Width := 120;
  179.           END;
  180.           FOR i:= 13 TO 17 DO
  181.             Items[i].TopEdge := (i-13) * 10;
  182.             Items[i].Width := 230;
  183.           END; 
  184.           FOR i:= 18 TO 22 DO
  185.             Items[i].TopEdge := (i-18) * 10;
  186.             Items[i].Width := 130;
  187.           END; 
  188.           FOR i:= 23 TO 34 DO
  189.             Items[i].TopEdge := (i-23) * 10;
  190.           END; 
  191.           (* Now put text into the text arrays *)
  192.           Text[0] := "written by Ed Bartz";
  193.           Text[1] := "with TDI Modula 2";
  194.           Text[2] := " Version 1.04";
  195.           Text[3] := "   Copyright March 1987";
  196.           Text[4] := "            ";
  197.           Text[5] := "This Program is Shareware";
  198.           Text[6] := "Send  Donation to ";
  199.           Text[7] := "    12 Roosevelt St.";
  200.           Text[8] := "    SouthRiver,N.J. 08882";
  201.           Text[9] := "Random Setup ";
  202.           Text[10] := "Play Game";
  203.           Text[11] := "Stop Game";
  204.           Text[12] := "Quit";
  205.           Text[13] := "Maximum Planets =  9";
  206.           Text[14] := "Erase Missle Trails";
  207.           Text[15] := "Redraw Screen";
  208.           Text[16] := "Plain Planets";
  209.           Text[17] := "Practice";
  210.           Text[18] := "Move Ship";
  211.           Text[19] := "Move Planet";
  212.           Text[20] := "Change Planet";
  213.           Text[21] := "Make Planet";
  214.           Text[22] := "Delete Planet";
  215.           Text[23] := "Velocity: 0 to 10";
  216.           Text[24] := "         ";
  217.           Text[25] := "Angle:   90";
  218.           Text[26] := "         |";
  219.           Text[27] := "   180 --+-- 0";
  220.           Text[28] := "         |";
  221.           Text[29] := "        270";
  222.           Text[30] := "         ";
  223.           Text[31] := "Planet Density:";
  224.           Text[32] := "   Low - Red";
  225.           Text[33] := "   Medium - Green";
  226.           Text[34] := "   High - Blue ";
  227.       END;
  228.     END InitItems;
  229.  
  230.     BEGIN 
  231.       InitItems ();
  232.       (* Init the single menu *)
  233.         WITH GravityWarsmenu DO
  234.           WITH menu[0] DO
  235.             NextMenu := ADR (menu[1]);
  236.             LeftEdge := 3; TopEdge := 0;
  237.             Width := 55; Height := 10;
  238.             Flags := MenuFlagSet {MenuEnabled};
  239.             FirstItem := ADR (Items[0]);
  240.             MenuName := ADR (menuname[0])
  241.           END;
  242.           WITH menu[1] DO
  243.             NextMenu := ADR (menu[2]);
  244.             LeftEdge := 65; TopEdge := 0;
  245.             Width := 44; Height := 10;
  246.             Flags := MenuFlagSet {MenuEnabled};
  247.             FirstItem := ADR (Items[23]);
  248.             MenuName := ADR (menuname[1])
  249.           END;
  250.           WITH menu[2] DO
  251.             NextMenu := ADR (menu[3]);
  252.             LeftEdge := 119; TopEdge := 0;
  253.             Width := 132; Height := 10;
  254.             Flags := MenuFlagSet {MenuEnabled};
  255.             FirstItem := ADR (Items[9]);
  256.             MenuName := ADR (menuname[2])
  257.           END;
  258.           WITH menu[3] DO
  259.             NextMenu := ADR (menu[4]);
  260.             LeftEdge := 261; TopEdge := 0;
  261.             Width := 77; Height := 10;
  262.             Flags := MenuFlagSet {MenuEnabled};
  263.             FirstItem := ADR (Items[13]);
  264.             MenuName := ADR (menuname[3])
  265.           END;
  266.           WITH menu[4] DO
  267.             NextMenu := NULL;
  268.             LeftEdge := 348; TopEdge := 0;
  269.             Width := 132; Height := 10;
  270.             Flags := MenuFlagSet {MenuEnabled};
  271.             FirstItem := ADR (Items[18]);
  272.             MenuName := ADR (menuname[4])
  273.           END;
  274.           menuname[0] := "About";
  275.           menuname[1] := "Help";
  276.           menuname[2] := "Game Control";
  277.           menuname[3] := "Options";
  278.           menuname[4] := "Modify Setup";
  279.               END;
  280.   END InitMenu;
  281. (*++++++++++++++++++++++++++++++++++++++ *)
  282.   PROCEDURE SetColors (sp : ScreenPtr);
  283.     BEGIN
  284.       WITH sp^ DO
  285.         SetRGB4 (ADR(VPort), 0, 0, 0, 0);
  286.         SetRGB4 (ADR(VPort), 1, 15, 15, 15);
  287.         SetRGB4 (ADR(VPort), 2, 15, 0, 0);
  288.         SetRGB4 (ADR(VPort), 3, 8, 8, 9);
  289.         SetRGB4 (ADR(VPort), 4, 6, 0, 0);
  290.         SetRGB4 (ADR(VPort), 5, 9, 1, 0);
  291.         SetRGB4 (ADR(VPort), 6, 12, 2, 0);
  292.         SetRGB4 (ADR(VPort), 7, 15, 3, 0);
  293.         SetRGB4 (ADR(VPort), 8, 0, 5, 0);
  294.         SetRGB4 (ADR(VPort), 9, 1, 8, 0);
  295.         SetRGB4 (ADR(VPort), 10, 2, 12, 0);
  296.         SetRGB4 (ADR(VPort), 11, 7, 15, 0);
  297.         SetRGB4 (ADR(VPort), 12, 0, 0, 6);
  298.         SetRGB4 (ADR(VPort), 13, 0, 2, 9);
  299.         SetRGB4 (ADR(VPort), 14, 0, 4, 12);
  300.         SetRGB4 (ADR(VPort), 15, 0, 6, 15);
  301.        END
  302.    END SetColors;
  303.  
  304.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  305.     PROCEDURE ReadMenu(wp : WindowPtr): INTEGER;
  306.  
  307.       CONST
  308.         MenuNull = 0FFFFH;
  309.  
  310.       VAR
  311.         msgptr : IntuiMessagePtr;
  312.         code   : CARDINAL;
  313.         class  : IDCMPFlagSet;
  314.  
  315.     (* ++++++++++++++++++++++++++++++++++++++ *)
  316.     (* Get the item number from the number    *)
  317.     (* gotten from the intuition message.     *)
  318.  
  319.       PROCEDURE ItemPicked (code : CARDINAL) : CARDINAL;
  320.         TYPE
  321.           ShortSet = SET OF [0..15];
  322.         VAR
  323.           menunumber,code1  : CARDINAL;
  324.  
  325.         BEGIN
  326.           code1 := code;
  327.           code1 := CARDINAL (ShortSet(code1) * ShortSet (0001FH));
  328.           code := CARDINAL (ShortSet(code DIV 32) * ShortSet (003FH));
  329.           IF (code1 = 0) THEN code:= 0;END;
  330.           IF (code1 = 1) THEN code:= 0;END;
  331.           IF (code1 = 2) THEN code:= code + 1;END;
  332.           IF (code1 = 3) THEN code:= code + 5;END;
  333.           IF (code1 = 4) THEN code:= code + 10;END;
  334.           RETURN code
  335.         END ItemPicked;
  336.  
  337.       BEGIN
  338.         msgptr := GetMsg (wp^.UserPort);
  339.         IF msgptr <> NULL THEN
  340.           (* If message is gotten. Process it *)
  341.           REPEAT
  342.              class := msgptr^.Class;  code  := msgptr^.Code;
  343.              ReplyMsg (MessagePtr(msgptr));
  344.              msgptr := GetMsg (wp^.UserPort);
  345.              (* If something was picked from the menu, act on it *)
  346.              (* If not a menu event check next message *)
  347.           UNTIL ((msgptr=NULL) OR (class = IDCMPFlagSet {MenuPick}));
  348.              IF (class = IDCMPFlagSet {MenuPick}) AND (code <> MenuNull) THEN
  349.                (* Figure out what item was picked *)
  350.                RETURN ItemPicked (code);
  351.              END
  352.          END; (* IF msgptr <> NULL *)
  353.       RETURN 0;
  354.     END ReadMenu;
  355.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  356.     PROCEDURE QueueMenu(wp : WindowPtr): BOOLEAN;
  357.  
  358.       CONST
  359.         MenuNull = 0FFFFH;
  360.  
  361.       VAR
  362.         msgptr : IntuiMessagePtr;
  363.         code   : CARDINAL;
  364.         class  : IDCMPFlagSet;
  365.  
  366.       BEGIN
  367.         msgptr := GetMsg (wp^.UserPort);
  368.         IF msgptr <> NULL THEN
  369.           REPEAT
  370.              class := msgptr^.Class;  code  := msgptr^.Code;
  371.              msgptr := GetMsg (wp^.UserPort);
  372.           UNTIL ((msgptr=NULL) OR (class = IDCMPFlagSet {MenuPick}));
  373.              IF (class = IDCMPFlagSet {MenuPick}) AND (code <> MenuNull) THEN
  374.                RETURN TRUE;
  375.              END
  376.          END;
  377.       RETURN FALSE;
  378.     END QueueMenu;
  379.   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  380.     PROCEDURE ReadMouse(wp: WindowPtr;VAR x,y: CARDINAL);
  381.  
  382.       VAR
  383.         msgptr : IntuiMessagePtr;
  384.         code : CARDINAL;
  385.         class : IDCMPFlagSet;
  386.  
  387.       BEGIN
  388.         REPEAT
  389.           msgptr:= NULL;
  390.           WHILE (msgptr=NULL) DO
  391.             msgptr:= GetMsg(wp^.UserPort);
  392.           END;
  393.           class:= msgptr^.Class;
  394.           code:= msgptr^.Code;
  395.           x:= CARDINAL(ABS(msgptr^.MouseX));
  396.           y:= CARDINAL(ABS(msgptr^.MouseY));
  397.           ReplyMsg (MessagePtr(msgptr));
  398.         UNTIL ((class=IDCMPFlagSet{MouseButtons})AND(code=SelectDown));
  399.       END ReadMouse;
  400. END MyWindow.
  401.